00100	;-----------------------------------------------------------------
00200	INTERN OLD44,FILM,BLKCNT,AVAIL
00300		OLD44:	0
00400		FILM:	0
00500		BLKCNT: 0
00600		AVAIL:	0
00700		REMAINDER:0
00800		NODSIZ←←7
00900	SUBR(MORCOR)------------------------------------------------------
01000	BEGIN MORCOR; - GET MORE CORE - BGB - 4 DEC 1972.
01100	
01200	;INITIALIZE FILM BLOCK POINTERS WHEN NECESSARY.
01300		SKIPE OLD44↔GO L1
01400		LAC 1,44↔DAC 1,OLD44
01500		AOS 1↔DAC 1,FILM
01600		ADDI 1,3↔DAC 1,AVAIL
01700		AOS 1↔DAC 1,BLKCNT
01800		SETZM REMAINDER
01900	
02000	;FOUR MORE K !
02100	L1:	LAC 1,44↔LAC 0,1↔ADDI 0,10000
02200		CALLI 11↔GO[FATAL(NO MORE CORE.)]
02300		AOS 1↔SUB 1,REMAINDER↔DAC 2,AC2#↔LAC 2,44
02400		SETZM(1)↔LIPI(1)↔LAPI(1)1↔BLT(2)
02500	
02600	;MAKE AVAIL LIST.
02700		DIP 1,1↔ADD 1,[XWD NODSIZ,0]
02800		SKIPE@BLKCNT↔GO .+3
02900		ADD 1,[XWD NODSIZ,NODSIZ]↔AOS@BLKCNT
03000		DAPZ 1,@AVAIL
03100	L2:	HLRZM 1,(1)↔ADD 1,[XWD NODSIZ,NODSIZ]
03200		CAILE 2,NODSIZ+NODSIZ-1(1)↔GO L2
03300		SUBI 2,NODSIZ-1(1)↔DAC 2,REMAINDER
03400		LACI 10000↔ADDM @FILM
03500		LAC 1,FILM↔LAC[FILBIT+010000]↔DAC 2(1)
03600		LAC 1,@AVAIL
03700		LAC 2,AC2↔POP0J
03800	BEND;12/16/72-----------------------------------------------------
     

00100	SUBR(MAKE)TYPE,,RELOC---------------------------------------------
00200	BEGIN MAKE; ALLOCATE A NODSIZ BLOCK OF WORDS - BGB - 4 DEC 1972.
00300		SKIPN 1,@AVAIL
00400		CALL(MORCOR)
00500		CDR(1)↔DAP @AVAIL
00600		SETZM(1)↔AOS @BLKCNT
00700		POP P,.+3↔POP P,2(1)↔GO @.+1↔0
00800		POP1J
00900	BEND;1/10/73------------------------------------------------------
01000	
01100	SUBR(KILL)NODE----------------------------------------------------
01200	BEGIN KILL; - RELEASE A NODSIZ BLOCK OF WORDS - BGB - 4 DEC 1972.
01300		LAC 1,ARG1
01400		SKIPN 2(1)↔GO[OUTSTR[ASCIZ/	EMPTY NODE KILLED.
01500	/]↔POP1J]↔SOS @BLKCNT
01600		SETZM(1)↔LIPI(1)↔LAPI 1(1)↔BLT NODSIZ-1(1)
01700		LAC @AVAIL↔DAPZ(1)↔DAPZ 1,@AVAIL
01800		POP1J
01900	BEND;12/17/72-----------------------------------------------------
02000	
02100	SUBR(RINGIN)------------------------------------------------------
02200	BEGIN RINGIN;(PART,WHOLE) RING PART INTO A WHOLE -BGB- 6 DEC 1972.
02300		LAC 1,ARG2
02400		LAC 3,ARG1
02500		SON 2,3
02600		JUMPE 2,[SON. 1,3↔DIP 1,(1)↔DAP 1,(1)↔POP2J]
02700		CAR 3,(2)
02800		DIP 3,(1)↔DAP 1,(3)
02900		DAP 2,(1)↔DIP 1,(2)
03000		POP2J↔LIT
03100	BEND;1/10/73------------------------------------------------------
     

00100	SUBR(SHRINK)------------------------------------------------------
00200	BEGIN SHRINK;SHRINK NODE SPACE - BGB - 17 JANUARY 1973.
00300		ACCUMULATORS{A,HOLE,BREAK,NODE}
00400		LAC@BLKCNT↔IMULI NODSIZ↔ADD FILM
00500		DAC BREAK↔LACI NODE,-NODSIZ(BREAK)↔SKIPA HOLE,FILM
00600	
00700	;FIND A HOLE BELOW THE BREAK.
00800	L1:	ADDI HOLE,NODSIZ↔CAML HOLE,BREAK↔GO L3
00900		TYPE 0,HOLE↔JUMPN 0,L1
01000	
01100	;FIND A NODE ABOVE THE BREAK.
01200	L2:	ADDI NODE,NODSIZ
01300		CAML NODE,44↔GO[FATAL({SHRINK - NODE CNT TOO BIG.})]
01400		TYPE 0,NODE↔JUMPE 0,L2
01500	
01600	;MOVE THE NODE INTO THE HOLE.
01700		DIP NODE,0↔DAP HOLE,0
01800		BLT 0,NODSIZ-1(HOLE)
01900		DAPZ HOLE,0(NODE)	;NODE'S NEW LOCATION.
02000		GO L1
02100	
     

00100	;REPLACE LINKS ABOVE THE BREAK WITH THEIR NEW VALUES.
00200		DEFINE KAR(Q){
00300			CAR 1,Q(A)
00400			CAML 1,BREAK↔LAC 1,0(1)
00500			DIP 1,Q(A)↔GO .+1}
00600		DEFINE KDR(Q){
00700			CDR 1,Q(A)
00800			CAML 1,BREAK↔LAC 1,0(1)
00900			DAP 1,Q(A)↔GO .+1}
01000	
01100	L3:	LAC A,FILM	;BLOCK POINTER.
01200	L4:	RELOC 0,A↔TRNE 400000↔LACI 333333
01300		TRNE 200000↔GO[KAR 0]↔ TRNE 100000↔GO[KDR 0]
01400		TRNE 20000 ↔GO[KAR 1]↔ TRNE 10000 ↔GO[KDR 1]
01500		TRNE 2000  ↔GO[KAR 3]↔ TRNE 1000  ↔GO[KDR 3]
01600		TRNE 200   ↔GO[KAR 4]↔ TRNE 100   ↔GO[KDR 4]
01700		TRNE 20    ↔GO[KAR 5]↔ TRNE 10    ↔GO[KDR 5]
01800		TRNE 2     ↔GO[KAR 6]↔ TRNE 1     ↔GO[KDR 6]
01900		ADDI A,NODSIZ↔CAMGE A,BREAK↔GO L4
02000	
02100	;SHRINK CORE SIZE AND RESET AVAIL LIST.
02200		LAC 0,BREAK↔IORI 0,1777↔CALLI 0,11↔HALT	   ;SHRINK CORE.
02300		LAC 1,BREAK↔LAC 2,44↔DAPZ 1,@AVAIL	   ;NEW BOUNDS.
02400		LACI 0,1(1)↔DIP 1,0↔SETZM(1)↔BLT(2)	   ;CLEAR AVAILS.
02500		LACI 1(2)↔SUB FILM↔DAC@FILM		   ;NEW CORE SIZE.
02600	
02700		LIPI 1,NODSIZ(1)↔GO L6
02800	L5:	HLRZM 1,(1)↔ADD 1,[XWD NODSIZ,NODSIZ]
02900	L6:	CAILE 2,NODSIZ+NODSIZ-1(1)↔GO L5
03000		SUBI 2,NODSIZ-1(1)↔DAC 2,REMAINDER↔POP0J
03100	
03200		LIT
03300	BEND;1/17/73------------------------------------------------------